-----------------------------------------------------------------------------
-- |
-- Maintainer  :  Joost Visser
-- Stability   :  experimental
-- Portability :  portable
--
-- A tool for computing XSD metrics.
--
-----------------------------------------------------------------------------

module Main where

import Text.XML.HaXml.Wrappers (fix2Args)
import Text.XML.HaXml.Parse
import Text.XML.HaXml.Xml2Haskell (fReadXml, fWriteXml, showXml, fromElem)
import Language.XMLSchema.XMLSchemaLib
import IO
import Text.XML.HaXml.Types
import Text.ParserCombinators.HuttonMeijerWallace

import Data.Set (size,Set,(\\),fold)
import Data.SetExtras
import Data.Relation.GraphViz
import Data.Relation.Write (printRel)
import Data.Metrics
import Data.Graph.Metrics
import Data.Graph.Basics (ent,Gph)
import Data.Graph.Components
import Data.Map (intersectionWith,insert,keysSet)
import Data.Bag

import System.Environment (getArgs, getProgName)
import System.Exit (exitWith, exitFailure, ExitCode(..))
import System.Console.GetOpt
import System (system)


import Control.Monad (when, mapM_, foldM)

import Language.XMLSchema.Analysis
import Language.XMLSchema.Parse
import Language.XMLSchema.NameSpaces

-----------------------------------------------------------------------------

main :: IO ()
main = do
  opts <- parseOptions
  xsdMetz opts
  
xsdMetz :: Opt -> IO ()
xsdMetz opts = do
  -- putStrLn $ "Input dirs:        "++(show $ optInputDirs opts)
  -- putStrLn $ "Report file:       "++(show $ optReportFile opts)
  -- putStrLn $ "CSV file:          "++(show $ optCSVFile opts)
  -- putStrLn $ "Graph file prefix: "++(show $ optGraphFilePrefix opts)
  let clspth = optInputDirs opts
  clsnms <- foldM (\ns d -> findXsdFiles d >>= \ns' -> return (ns'++ns)) [] clspth
  -- putStrLn $ "Searching in directories: "++(show clspth)
  -- putStrLn $ "Chasing from files:       "++(show clsnms)
  schemas <- xsdChaseImports clspth clsnms
  putStrLn $ "Parsed "++ (show $ length schemas) ++" schemas."
  let impGraph = importGraph schemas
  let succGraph = successorGRAPH schemas
  let typeGraph = typeGRAPH schemas
  let globGraph = globalsGraph succGraph
  let compGraph = strongComponentGraph succGraph
  writeGraphs opts impGraph succGraph typeGraph globGraph compGraph
  metrics <- calcAllMetrics schemas impGraph succGraph globGraph compGraph
  let projectID = mkProjectID opts
  writeCSV projectID opts (map splitBasicStats metrics)
  writeReport projectID opts (map showBasicStats metrics)

mkProjectID :: Opt -> String
mkProjectID opts
 = maybe (head (optInputDirs opts)) id (optProjectID opts)

calcAllMetrics schemas impGraph succGraph globGraph compGraph = do
  let sCM = calculateComponentMetrics height (ent succGraph) compGraph
  let gCM = calculateComponentMetrics height (ent succGraph) (ent globGraph,globGraph)
  let iCM = calculateComponentMetrics height (ent impGraph) (strongComponentGraph impGraph)
  xmlAgnosticMetrics <- calcXmlAgnosticMetrics $ map absoluteFileName schemas
  return [
    liftLeft xmlAgnosticMetrics,
    liftLeft $ calcXsdAgnosticMetrics $ map rawSchema schemas,
    liftLeft $ calcXsdAwareMetrics $ map parsedSchema schemas,
    liftLeft $ mcCabeComplexityMetrics schemas,
    liftLeft $ calcXsdFeatureMetrics schemas,    
    calcGraphMetrics "Successor graph metrics" succGraph,
    calcGraphMetrics "Globals graph metrics (basic)" globGraph,
    calcGraphMetrics "Component graph metrics (basic)" (snd compGraph),
    calcGraphMetrics "Import/include/redefine graph metrics (basic)" impGraph,
    liftLeft $ calcComponentGraphMetrics "Globals graph metrics (advanced)" gCM,
    liftLeft $ calcComponentGraphMetrics "Component graph metrics (advanced)" sCM,
    liftLeft $ calcComponentGraphMetrics "Import/include/redefine graph metrics (advanced)" iCM,
    calcMetricsByToplevel succGraph,
    -- calcMetricsByStrongComponents succGraph -- NOTE: slow because repeats strong component analysis!!
    calcCouplingMetrics' "Component graph metrics (coupling & coherence)" (fst compGraph) succGraph
   ]

writeReport projectID opts metrics = do 
  reportHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optReportFile opts)
  let reportHandleName = maybe "standard output" id (optReportFile opts)
  hPutStrLn reportHandle $ unlines $ ["XsdMetz -- Metrics report for "++projectID,""]
  hPutStrLn reportHandle $ unlines $ printGroupMetricList metrics
  maybe (return ()) (\_ -> hClose reportHandle) (optReportFile opts)
  putStrLn $ "Wrote metrics report to "++reportHandleName

writeCSV projectID opts metrics = case optCSVFile opts of
    Nothing        -> return ()
    (Just cvsName) -> do
      (openFile cvsName ReadMode >>= hClose) `catch` \err ->
        if isDoesNotExistError err
          then writeFileLn cvsName (csvLine $ ("PROJECT":) $ printGroupMetricHeaderRow metrics) >>
               hPutStrLn stderr ("Wrote header to: "++cvsName)
          else ioError err
      cvsHandle <- openFile cvsName AppendMode
      hPutStrLn cvsHandle (csvLine $ (projectID:) $ printGroupMetricRow metrics)
      hClose cvsHandle
      hPutStrLn stderr ("Appended row to: "++cvsName)
      
writeFileLn fn str = writeFile fn (str++"\n")

csvLine :: [String] -> String
csvLine = concat . sepBy ", "

sepBy sep [] = []
sepBy sep [x] = [x]
sepBy sep (x:xs) = x:sep:(sepBy sep xs)

writeGraphs opts impGraph succGraph typeGraph globGraph compGraph
 = case (optGraphFilePrefix opts) of
    Nothing    -> return ()
    (Just pfx) -> do
      writeFile' (pfx++"impt-graph.dot") (printGraphWith id (const id) "IG" impGraph)
      writeFile' (pfx++"succ-graph.dot") (printSuccGph succGraph)
      writeFile' (pfx++"type-graph.dot") (printTypeGph typeGraph)
      writeFile' (pfx++"glob-graph.dot") (printXsdComponentGph "GG" globGraph)
      writeFile' (pfx++"comp-graph.dot") (printXsdComponentGph "CG" $ snd compGraph)

writeFile' nm ctnt = do
  writeFile nm ctnt
  hPutStrLn stderr ("Wrote "++nm)  

--main = fix2Args >>= uncurry main'

{-
main' infile outfile = do
  fileContent <- readFile infile
  let (Document _ _ xmlElement) = xmlParse infile fileContent
  let z = maybe (error "[ERROR] Parse error in schema. Aborting.") id (fst (fromElem [CElem xmlElement]))
  let value@(Xs'schema attrs l1 l2) = z 
  -- putStrLn (take 2500 (show value))
  -- putStrLn $ "Element names " ++ (show $ collectElementNames value)
  let nse = createNameSpaceEnv xmlElement
  -- putStrLn $ show nse
  putStrLn $ "Target prefix: "++(show $ targetPrefix nse)
  let succGraph = successorGraph nse value
  writeFile "succ-graph.dot" (printSuccGph succGraph)
  let globGraph = globalsGraph succGraph
  writeFile "glob-graph.dot" (printXsdComponentGph "GG" globGraph)
  let compGraph = strongComponentGraph succGraph
  writeFile "comp-graph.dot" (printXsdComponentGph "CG" $ snd compGraph)
  -- | Using (const -1) instead of height, otherwise performance dies.
  let sCM = calculateComponentMetrics (height) (ent succGraph) compGraph
  -- | Using (const -1) instead of height, otherwise performance dies.
  let gCM = calculateComponentMetrics (height) (ent succGraph) (ent globGraph,globGraph)
  putStrLn $ unlines $ printGroupMetricList [
    calcXsdAgnosticMetrics [xmlElement],
    calcXsdAwareMetrics [value],
    calcXsdFeatureMetrics [(infile,xmlElement,value,nse,infile)],
    calcGraphMetrics "Successor graph metrics" succGraph,
    calcGraphMetrics "Globals graph metrics (basic)" globGraph,
    calcGraphMetrics "Component graph metrics (basic)" (snd compGraph),
    calcComponentGraphMetrics "Globals graph metrics (advanced)" gCM,
    calcComponentGraphMetrics "Component graph metrics (advanced)" sCM,
    calcMetricsByToplevel succGraph,
    -- calcMetricsByStrongComponents succGraph -- NOTE: slow because repeats strong component analysis!!
    calcCouplingMetrics' "Coupling metrics for strong components" (fst compGraph) succGraph
   ]
-}

-----------------------------------------------------------------------------
-- * Command line options

-- | Record type to hold all program options.
data Opt = Opt
   { -- | Input files
     optInputFiles :: [FilePath]
     -- | Input directories
   , optInputDirs :: [FilePath]
     -- | Project identifier
   , optProjectID :: Maybe String
     -- | Text file into which to write or append textual report
   , optReportFile :: Maybe FilePath
     -- | CSV file into which to write or append single metrics line
   , optCSVFile :: Maybe FilePath
     -- | Prefix for files into which to write DOT graphs
   , optGraphFilePrefix :: Maybe FilePath
   }

-- | Default options.
startOpt :: Opt
startOpt = Opt
   { optInputFiles       = []
   , optInputDirs        = []
   , optProjectID        = Nothing
   , optReportFile       = Nothing
   , optCSVFile          = Nothing
   , optGraphFilePrefix  = Nothing
   }

-- | Description of all available program options.
options :: [OptDescr (Opt -> IO Opt)]
options =
   [ Option "h" ["help"] 
        (NoArg (\opt -> exitHelp)) 
        "Show usage info"
{-
   , Option "i" ["input"] 
        (ReqArg 
           (\arg opt -> do
              return opt { optInputFiles = arg:(optInputFiles opt) })
           "FILE")        
        "Input file"
-}
   , Option "I" ["Input"] 
        (ReqArg 
           (\arg opt -> do
              return opt { optInputDirs = arg:(optInputDirs opt) })
           "DIR")        
        "Input directory"
   , Option "p" ["project"]
        (ReqArg
           (\arg opt -> do
              return opt { optProjectID = Just arg })
           "NAME")
        "Project identifier (if absent, first -I argument is used)"
   , Option "r" ["report"]
        (ReqArg
           (\arg opt -> do
              return opt { optReportFile = Just arg })
           "FILE")
        "Report file (default: stdout)"
   , Option "c" ["csv"]
        (ReqArg
           (\arg opt -> do
              return opt { optCSVFile = Just arg })
           "FILE")
        "CSV file"
   , Option "g" ["graphs"]
        (ReqArg
           (\arg opt -> do
              return opt { optGraphFilePrefix = Just arg })
           "FILE")
        "Prefix for graph files"
   ]

-- * Functions to parse and deal with program options

-- | Function that reads arguments from the environment and parses it according
-- with the rules specified in the 'options' type.
parseOptions :: IO Opt
parseOptions = do
   -- Reads the options to a triple
   (optsActions, rest, errs) <- getArgs >>= return . getOpt RequireOrder options

   -- If there are errors show them, show the usage and exit with failure code
   when (not (null errs)) $ do
      mapM_ (hPutStrLn stderr) errs
      showHelp
      exitFailure
   
   -- If no options were specified then show the help and exit with failure 
   -- code. The "rest" is used to save multiple files passed as options, thus
   -- it must be tested.
   when ((null optsActions) && (null rest)) $ do
      showHelp
      exitFailure
            
   -- create a record with all program options            
   opts <- foldl (>>=) (return startOpt) optsActions
   
   -- verify if at least one input argument exists. This can be specified both
   -- with "i" option or just passing the names of the files 
   when ((null rest) && (optInputFiles opts == []) && (optInputDirs opts == [])) $ do
      exitErrorHelp "At least one input file is required"
      
   -- return all the parsed options   
   return opts { optInputFiles = (optInputFiles opts) ++ rest }


-- | Function that prints the help usage and returns with a success code (used
--   when the help program option is specified.
exitHelp :: IO a
exitHelp = do
    showHelp
    exitWith ExitSuccess

-- | Function that prints the program usage to the sdtderr using the standard
--   'usageInfo' function.
showHelp :: IO ()
showHelp = do
    prg <- getProgName
    let header = unlines [prg++" -- Computes metrics for XML Schema","",
                          "Usage: "++prg++" [OPTION...]"]
    hPutStrLn stderr (usageInfo header options)
    hFlush stderr

-- | Helper function that prints a message to stderr and exits with a failure
--   code error
exitErrorHelp :: String -> IO ()
exitErrorHelp msg = do
   hPutStrLn stderr ("Error: " ++ msg)
   hPutStrLn stderr ""
   showHelp
   exitFailure

-- | Find XSD files inside a directory.
--   Returns file names relative to that directory.
findXsdFiles :: FilePath -> IO [FilePath]
findXsdFiles dir = do
  let findCmd = "find "++dir++" -iname \"*.xsd\" > /tmp/find.results"
  system findCmd
  findResults <- readFile "/tmp/find.results"
  let fnames = map dropLeadingSlash $ map (drop (length dir)) $ lines findResults
  -- putStrLn $ "Found: "++(show fnames)
  return fnames
 where
  dropLeadingSlash ('/':fname) = fname
  dropLeadingSlash fname = fname
  
-----------------------------------------------------------------------------
-- * These should be moved to the libraries.


--

printSuccGph = printGraphWith show (const showXsdNode) "SuccessorGraph"

printTypeGph = printGraphWith show (const showXsdNode) "TypeGraph"

printXsdComponentGph :: GraphName -> Gph (Set XsdNode) -> DotGraph
printXsdComponentGph graphName = printComponentGraphWith show showXsdNode graphName

{-
showFormattedSet xs = shows 0 lst
  where
    lst = setToList xs
    max = Data.Set.size xs
    mx = maximum (max:(map (length.showXsdNode) lst))
    shows l []      = ""
    shows 0 (x:xs)  = wrd++(shows (length wrd) xs) where wrd = showXsdNode x
    shows l (x:xs) 
      | l' > mx   = '\\':'n':(shows 0 (x:xs))
      | otherwise  = ' ':wrd++(shows l' xs)
      where 
        l' = l+(length wrd)+1
        wrd = showXsdNode x
-}

calcMetrics graph =
  let sCM = calculateStrongComponentMetrics graph
  in GroupMetric "Structural Metrics" 
     [ Metric "Tree impurity" "TIMP" (show $ treeImpurity graph),
       Metric "Tree impurity after trans. closure" "TIMP2" (show $ treeImpurityTC graph),
       Metric "Count of levels" "LEV" (show $ componentCount sCM),
       Metric "Normalized Count of Levels" "CLEV" (show $ componentCountNormalized sCM),
       Metric "Nr of Non-singleton Levels" "NSLEV" (show $ nonSingletonComponentCount sCM),
       Metric "Size of largest levely" "DEP" (show $ componentSizeMax sCM),
       Metric "Maximum height" "HEI" (show $ heightOfComponentGraph sCM)
     ]

calcGraphMetrics title graph =
  GroupMetric' title [ 
       Left $ mkMetric "Number of nodes" "NODES" (show $ Data.Set.size $ ent graph),
       Left $ mkMetric "Number of edges" "EDGES" (show $ Data.Set.size graph),
       -- Metric "Height" "HEI" (show $ height graph),  -- TOO SLOW
       Left $ mkMetric "Tree impurity" "TIMPi" (show $ treeImpurity graph),
       -- Metric "Tree impurity after trans. closure" "TIMP2" (show $ treeImpurityTC graph),
       Right $ mkMetric "Fan in" "FI" (basicStats' nodes $ fm fin),
       Right $ mkMetric "Fan out" "FO" (basicStats' nodes $ fm fout),
       Right $ mkMetric "Instability based on fan" "IF" (basicStats' nodes ifan')
  ] where
     (fin,fout) = fanInOut graph
     -- Note: nodes missing from fin should have ifan=100.
     ifan = intersectionWith (\ca ce -> ce `asPercentageOf` (ca+ce)) (fm fin) (fm fout)
     ifan' = fold (\k mp -> insert k 100 mp) ifan (nodes \\ (keysSet $ fm fin))
     nodes = ent graph
     -- Prefix abbreviation with first letter of the graph name.
     mkMetric desc abbrev = Metric desc ((head title):abbrev)
       
calcComponentGraphMetrics title sCM =
  GroupMetric title [
       mkMetric "Count of levels" "LEV" (show $ componentCount sCM),
       mkMetric "Normalized Count of Levels" "CLEV" (show $ componentCountNormalized sCM),
       mkMetric "Nr of Non-singleton Levels" "NSLEV" (show $ nonSingletonComponentCount sCM),
       mkMetric "Size of largest levely" "DEP" (show $ componentSizeMax sCM),
       mkMetric "Maximum height" "HEI" (show $ heightOfComponentGraph sCM)
  ] where
     -- Prefix abbreviation with first letter of the graph name.
     mkMetric desc abbrev = Metric desc ((head title):abbrev)
     
     
--



-----------------------------------------------------------------------------
